Libris Britannia 4/science library(b).zip/science library(b)/PROGRAMM/PROGEDIT/1023.ZIP/GLWP.PAS

Pascal/Delphi Source File | 1986-03-14 | 55KB | 2,135 lines

{$I-,V-,C-,U-,K-,D-}
Program Words;

CONST
  OFF        = false;
  ON         = True;
  ENDLINE    = 4021;
  TOPEND     = 4000;
  cnotice    = '  Copyright  1986,  K. D. Sherrets,  P. O. Box 37093,  Omaha,  NE   68137';
type
  str255 = string[255];
  Str80 = String[80];
  CharSet = Set of Char;
  registers = Record case integer of
                 0 : (ax,bx,cx,dx,bp,si,di,ds,es,flags: integer);
                 1 : (al,ah,bl,bh,cl,ch,dl,dh : byte);
              End;

  Screentype  = array [1..4000] of byte;
  WPLine = String[79];
var
  Astring    : string[80];
  Att,
  fcol,
  frow       : byte;
  Aendline   : integer;
  Atopend    : integer;
  heaptop    : ^integer;
  Cdir,
  WPFileVar,
  DFilevar,
  tempfile   : String[60];
  WPFileName : text[$F00];
  DFileName  : text[$F00];
  WrapOn,
  MarkBlock,
  SAVED      : BOOLEAN;
  sline      : array [1..endline] of ^wpline;
  dline      : array [1..99] of string[79];
  nomem,
  noprint,
  formright,
  Inserton   : Boolean;
  lns,
  PriorLN,
  MarkOne,
  MarkTwo,
  xx,
  MAXLN,
  LNN        : Integer;
  newline,
  ckln       : string[80];
  Fword,
  Junk,
  Temp,
  Tbuff      : string[79];
  pageYN,
  pause,
  priorch,
  NumYn,
  Ch,
  zip,
  YN         : Char;
  Last,
  LineNum,
  priorP,
  PP,
  Header,
  Bottom,
  margin,
  pagesize,
  count,
  linewidth,
  TopLine,
  online,
  OldXpos,
  OldYpos,
  Crtmode     : integer;
  Screen      : Screentype;
  Monobuffer  : Screentype absolute $B000:$0000;
  Colorbuffer : Screentype absolute $B800:$0000;


PROCEDURE Typeadapter;
var
  regs  : registers;
BEGIN
   with regs do
   begin
     ah := 15;
     intr($10,regs);
     crtmode := al;
   end;
END;

PROCEDURE bigw;
begin
  window(1,1,80,25);
end;

PROCEDURE littlew;
begin
  window(1,1,80,22);
end;


PROCEDURE BEEP;
begin
   Write(chr(7));
end;

PROCEDURE PromptAt(x : byte; y : byte; promptstr : str80);
begin
  gotoxy(x,y);
  write(promptstr);clreol;
end;

PROCEDURE cursor(switchon : boolean);
var
   regs  : registers;
begin
  with regs do
  begin
    if crtmode <> 7 then
    begin
      if switchon then ch := 6 else ch := $20;
      cl := 7;
    end
    else
    begin
      if switchon then ch := 12 else ch := $20;
      cl := 13;
    end;
    ah := 1;
    intr($10,regs);
  end;
end;

PROCEDURE TextInfo;
var
   pageno : integer;
begin
   bigw;
   lowvideo;
   cursor(off);
   if maxln >= aendline -6 then
   begin
     PromptAt(1,24,'Warning - Text Buffer full!  Save your file');
     write(chr(7));
   end;
   gotoxy(20,25);
   pageno := (lnn div (1+ pagesize -header-bottom)) + 1;
   write('Page: ',pageno,', Line: ',LNN,', Col: ',pp+1,', Lines Used: ',maxln);clreol;
   cursor(on);
   highvideo;
end;

PROCEDURE wpstatus;
begin
  bigw;
  PromptAt(1,24,'"F10" = Quit,  "Alt & F10" = Help');
  gotoxy(36,24);
  lowvideo;
  if InsertOn then write('Insert-On: ',WPFileVar)
  else write('Overwrite: ',WPFileVar);
  textinfo;
end;

PROCEDURE writewrapon;
begin
  bigw;
  lowvideo;
  gotoxy(1,25);clreol;
  if WrapOn then write('Word Wrap-ON  ') else write('Word Wrap-OFF ');
  highvideo;
end;


PROCEDURE Directwrite(col,row, attrib : byte; var str : str80);
begin
inline($1E/
       $1E/
       $8A/$86/ROW/
       $B3/$50/
       $F6/$E3/
       $2B/$DB/
       $8A/$9E/COL/
       $03/$C3/
       $03/$C0/
       $8B/$F8/
       $8A/$BE/ATTrib/
       $C4/$B6/Str/
       $2b/$c9/
       $26/$8A/$0C/
       $2B/$C0/
       $8E/$D8/
       $A0/$49/$04/
       $1F/
       $2C/$07/
       $74/$21/
       $BA/$00/$B8/
       $8E/$DA/
       $BA/$DA/$03/
       $46/
       $26/$8A/$1C/
       $EC/
       $A8/$01/
       $75/$FB/
       $FA/
       $EC/
       $A8/$01/
       $74/$FB/
       $89/$1D/
       $47/
       $47/
       $E2/$EB/
       $2A/$C0/
       $74/$0F/
       $BA/$00/$B0/
       $8E/$DA/
       $46/
       $26/$8A/$1C/
       $89/$1D/
       $47/
       $47/
       $E2/$F6/
       $1F/
       $FB);
end;

PROCEDURE makenewline( x : integer);
begin
  if (sline[x] = nil) then
  begin
    if ((memavail * 16.0) -20000.0 < 1680) then
    begin
       gotoxy(1,1);
       write(^G,'You are running out of memory!'); delay(600);
    end;
    if ((memavail * 16.0) -20000.0 > 160) then
    begin
      new(sline[x]);
      sline[x]^ := '';
    end
    else begin write(^G,'Out Of Memory'); nomem := true; end;
  end;
end;

PROCEDURE VideoSignal(Switch : boolean);
var
   CrtAdapter : integer absolute $0040:$0063;
   VideoMode  : byte    absolute $0040:$0065;
Begin
  If (Switch = Off)
  then
  Port[CrtAdapter+4] := (VideoMode - $08)
  else
  Port[CrtAdapter+4] := (VideoMode or $08);
end;

procedure insertline(s : str80; lnn : integer);
var y,tcount,nln :integer;
begin
  y := wherey;
  insline;
  gotoxy(1,22);
  if y < 21 then clreol;
  bigw;
  littlew;
  gotoxy(1,y);
  tcount := 1;
  temp:= s;
  for NLN := LNN to MAXLN + 1 do
  begin
    makenewline(lnn + tcount);
    Tbuff := sline[LNN + tcount]^;
    sline[LNN + tcount]^ := temp;
    temp := Tbuff;
    tcount := tcount + 1;
  end;
  maxln :=maxln + 1;
end;

function rmblks(s : str80) : str80;
var  ct : integer;
begin
  if (length(s) > 1) and (pos(' ',s) <> 0) then
  begin
     ct :=0;
     s := s + ' ';
     while (length(s) > 0) and (s[1] = ' ') do delete(s,1,1);
     repeat
       ct := ct + 1;
       if (s[ct] = ' ') and (s[ct+1] = ' ') then delete(s,ct,1);
       if (ct = length(s)-1) and (pos('  ',s) <> 0) then ct := 0;
     until ct >= length(s)-1;
     while s[length(s)] = ' ' do delete(s,length(s),1);
  end;
  rmblks := s;
end;

procedure formpara(var curline :integer);
var
  useddlines,lastline,oln,nln,lw,y,nlcnt : integer;
  word : string[79];
  right,newpara : boolean;
  bufline : string[255];

procedure initialize;
var x:integer;
begin
  for x := 1 to 99 do dline[x] := '';
  right := false;
  newline := '';
  bufline := '';
  nlcnt := 0;
end;

PROCEDURE deletelines(curLn : integer; NumLn : integer);
var dnln : integer; termline : string[79];
begin
  for dnln := maxln to maxln + numln do makenewline(dnln);
  for dnln := curln-1 to maxln do sline[dnln]^ := sline[dnln+numln]^;
  for dnln := maxln to maxln + numln do sline[dnln]^ := '';
  maxln := maxln - numln;
end;

procedure spread(var newline : str80);
var i : integer;
   wch : char;
begin
  if pos(^M,newline) <> 0 then newpara := true else newpara := false;
  if ((length(newline) < lw) and (Not newpara)) and (pos(' ',newline) <> 0) then
  begin
      i := 0;
      if right then
      begin
        repeat
          i := i + 1;
          wch := newline[i];
          if wch = ' ' then
          begin
            insert(' ',newline,i+1);
            i := i + 1;
          end;
          if (i >= length(newline)) and (Length(newline) < lw) then i := 1;
        until (length(newline) >= lw);
      end
      else
      begin
        i := Length(newline);
        if i > 0 then
        while (length(newline) < lw) do
        begin
          i := i - 1;
          wch := newline[i];
          if wch = ' ' then
          begin
            insert(' ',newline,i + 1);
            i := i - 1;
          end;
          if i <= 1 then i := length(newline);
        end;
      end;
   end;
   if pos(^M,newline) <> 0 then delete(newline,pos(^M,newline),1);
 end;

function getword(var oldline : str255) : str80;
var wch : char; word : string[80]; i,L : integer;
begin
  word := '';
  i := 0;
  if length(oldline) > 0 then
  begin
    repeat
      i := i + 1;
      wch := oldline[i];
    until (wch = ' ') or (i = length(oldline));
    word := copy(oldline,1,i);
    delete(oldline,1,i);
  end;
  if length(word) >= (lw div 2) - 1 then
  begin
    beep;
    L := length(word) div 2;
    oldline := copy(word,L+1,255) + ' ' + oldline;
    word := copy(word,1,L);
  end;
  getword := rmblks(word);
end;

 procedure getlines;
 begin
   nln :=1;
   repeat
     dline[nln]  := rmblks(sline[oln]^);
     nln := nln + 1;
     oln := oln + 1;
   until (length(sline[oln]^) in [0,1]) or (nln = 99);
   lastline := oln-1;
   useddlines := nln-1;
   dline[nln-1] := rmblks(dline[nln-1]) + ^M;
 end;

function makestring : str80;
var done : boolean;
begin
   newline := '';
   done := false;
   repeat
     if (length(bufline) < (lw * 2)) and (nln < useddlines) then
     repeat
        nln := nln + 1;
        bufline := bufline + ' '+ dline[nln];
     until (length(bufline) > lw) or (nln = useddlines);
     word := getword(bufline);
     if (length(word) + length(newline)) <= lw then
        newline := newline + ' ' + word
     else
     begin
       done := true;
       bufline := word + ' '+ bufline;
     end;
   until done;
   makestring := rmblks(newline);
   nlcnt := nlcnt + 1;
end;

procedure formatlines;
var templine : string[80];
begin
   templine := ' ';
   bufline := bufline + ' '+ dline[nln];
   while (oln <= lastline + 1) and (templine <> '') do
   begin
     templine := makestring;
     if (sline[oln]^ = '') and (templine <> '' ) then
     begin
       insertline('X',oln);
       if templine <> '' then lastline := lastline + 1;
     end;
     sline[oln]^ := templine;
     lowvideo;
     if formright then spread(sline[oln]^) else
     if pos(^M,sline[oln]^) <> 0 then delete(sline[oln]^,pos(^M,sline[oln]^),1);
     write(sline[oln]^);clreol; writeln;
     oln := oln + 1;
  end;
  if (sline[oln]^ <> '') and (sline[oln-1]^ <> '') then insertline('',oln-1);
end;

procedure formatnotice;
begin
 astring :='Formating.   [please wait]';
 directwrite(0,24,135,astring);
end;

begin
  if sline[curline]^ <> '' then
  begin
    y :=wherey;
    bigw;
    gotoxy(1,24);clreol;
    gotoxy(1,25);clreol;
    Formatnotice;
    littlew;
    gotoxy(1,y);
    initialize;
    if formright then lw := linewidth else lw := linewidth + 5;
    oln := curline;
    getlines;
    oln := curline;
    nln := 1;
    formatlines;
    curline := oln;
    oln := (nln + 1) - nlcnt;
    if nlcnt < nln then deletelines(curline,oln);
    writewrapon;
    wpstatus;
  end
  else curline := curline + 1;
end;

PROCEDURE DrawWin(x1,y1,x2,y2 : integer);
var x,y : integer;
begin
  Window(1,1,80,25);
  gotoxy(x1,y1);  Write(chr(213));
  for x := x1+1 to x2-1 do Write(chr(205));  Write(chr(184));
  for y := y1+1 to y2-1 do
  begin
    gotoxy(x1,y); write(chr(179));
    gotoxy(X2,y); write(chr(179));
  end;
  gotoxy(x1,y2); write(chr(212));
  for x := x1+1 to x2-1 do write(chr(205)); write(chr(190));
  Window(x1+1,y1+1,x2-1,y2-1);
  ClrScr;
end;

PROCEDURE MakeWin(x1,y1,x2,y2 :integer);
begin
  VideoSignal(Off);
  If CrtMode = 7 then screen := monobuffer
  else screen := colorbuffer;
  VideoSignal(On);
  DrawWin(x1,y1,x2,y2);
end;

PROCEDURE RemoveWin;
Begin
  VideoSignal(Off);
  If crtmode = 7 then monobuffer := screen
  else colorbuffer := screen;
  VideoSignal(On);
  window(1,1,80,25);
end;

PROCEDURE center(var s: str80);
var xl : integer;
begin
  if length(s) > 0 then
  begin
    while (length(s)>0)and(s[1] = ' ') do delete(s,1,1);
    if length(s) >0 then
    for xl := 1 to ((linewidth - length(s)) div 2) do s:= ' '+s;
  end;
  gotoxy(1,wherey);
  write(s);clreol;
end;

PROCEDURE form;
begin
  LOWVIDEO;
  gotoxy(1,23); for xx := 1 to 80 do write(chr(205));
  HIGHVIDEO;
end;

function ioerr: boolean;
var err : integer;
begin
  err:= ioresult;
  if err <> 0 then
  begin
    ioerr := true;
    writeln;
    write(chr(7),' I/O Error # ',err,', ');
    case err of
     $01,$FF:write('File missing');
     $F1,240:write('Disk full or invalid Directory');
     $04:write('File not open');
     $99:write('Unexpected end of file');
     $08:write('Disk write error');
     $F2:write('File size overflow');
     $F0:write('Disk write error');
     $91:write('Seek beyond end of file');
     243,$F3:write('To many files open');
     else write(' error type unknown');
    end;
    write('. When ready Press <Return>');
    repeat read(kbd,ch) until ch = ^M;
    gotoxy(1,wherey);clreol;
  end
  else ioerr :=false;
end;

FUNCTION PrinterOK : boolean;
var ch : char;
var  reg:     registers;
       i:     integer;
begin
  repeat
    reg.ah := $02;
    reg.dx := $00;
    intr($17,reg);
    i := reg.ah;
    if (i = 144) then
    begin
      printerOk := True;
      ch := #27;
    end
    else
    begin
      printerOK := False;
      gotoxy(1,25);clreol;
      Write(^G,'Printer NOT READY!  When Ready Press <RETURN>,  To Quit Press <ESC>');
      repeat
        read(kbd,ch)
      until ch in[^M,#27];
      gotoxy(1,25);clreol;
    end;
  until ch in [#27];
end;

FUNCTION UpcaseStr(s: str80) : Str80;
var px : integer;
begin
  for Px := 1 to Length(s) do
  S[px] := Upcase(S[px]);
  UpcaseStr := S;
end;

FUNCTION Lowcase(ch : char) : CHAR;
begin
  if Ch in ['A'..'Z'] then lowcase := chr(ord(ch)+32)
  else lowcase := ch;
end;

{$I \turbo\Dirlst.pas}
{$I \turbo\sysutil.pas}

PROCEDURE help;
label quit;
var
  Hfile : text[$F00];
  hh,item : char;
  Line : string[80];
  Counter : integer;

begin
  OldxPos := wherex;
  OldyPos := wherey;
  counter:= 0;
  item := '0';
  makewin(2,1,78,24);
  clrscr;
  if Exist('GLWP.HLP') then
  begin
    Assign(Hfile,'GLWP.HLP');
    Reset(Hfile);
    if ioresult<> 0 then goto quit;
    while not Eof(Hfile) do
    begin
      gotoxy(1,1);
      LowVideo;
      repeat
          Readln(Hfile,Line);
      until  Eof(Hfile) or (Copy(Line,1,4)='.PA'+item);
      if ioresult <> 0 then goto quit;
      repeat
        Write(' ');
        if pos('.PA',line) = 0 then Writeln(line);
        Readln(Hfile,Line);
        if ioresult <> 0  then goto quit;
      until  Eof(Hfile) or (Copy(Line,1,3)= '.PA');
      GotoXY(12,22); highvideo;
      counter := counter + 1;
      if counter = 1 then write('Select Number or Press <Return> for All')
        else  write('< Press any key to continue or Press <ESC> to quit >');
      LowVideo;
      read(Kbd,hh);
      if hh in['0'..'9'] then item := hh else item :=succ(item);
      clrscr;
      if hh = #27 then goto quit;
    end;
    GotoXY(20,22); HighVideo;
    quit :
    close(Hfile);
    if ioerr then;
  end
  else
  begin
    gotoxy(1,1);
    write('Help File missing. Press <RETURN>');clreol;
    repeat Read(kbd,hh) until hh=^M;
  end;
  removewin;
  highvideo;
  gotoxy(OldxPos,OldyPos);
end;


PROCEDURE WPIBMCH(var Ch : Char);
var
   scancode : byte;
   extended : boolean;
   regs : registers;
begin
  regs.ah := $07;
  MsDos(regs);
  scancode := regs.al;
  if scancode = 0 then
  begin
    extended := true;
    MsDos(regs);
    scancode:= regs.al;
  end
  else extended := false;
  Ch := chr(scancode);
  if extended then
  begin
    case Ch of
          'Q' : Ch := ^C;  { page down key }
          'I' : Ch := ^R;  { page up key }
          'H' : Ch := ^E;  { up arrow key }
          'P' : Ch := ^X;  { down arrow key }
          'M' : Ch := ^D;  { right arrow key }
          'K' : Ch := ^S;  { left arrow key }
          'S' : Ch := ^G;  { delete key }
          ^O  : Ch := ^O;  { TAB KEY}
      ';','w' : Ch := ^U;  { F1 goto Top line}
      '<','u' : Ch := ^J;  { F2 Jump down to end}
          '=' : Ch := ^^;  { F3 find word}
          '>' : Ch := ^^;  { F4 find word}
          '?' : Ch := ^<;  { F5 upcase letter}
          '@' : Ch := ^\;  { F6 lower case}
          'A' : Ch := #205; { center}
          'B' : Ch := #132;  { Form para}
          '[' : ch := #133;  {reform para}
          'C' : Ch := ^N;  { F9 save file}
          'D' : Ch := ^Z;  { F10 quit enter}
          'R' : Ch := ^V;  { insert key }
          'O' : Ch := ^F;  { end key goto end of line}
          'G' : Ch := ^A;  { home key go to start of line}
          #113: ch := #206;
      else Ch := #00;
    End;
  end;
end;

PROCEDURE BOutWPForm;
var XX : integer;
begin
    gotoxy(1,1); clreol;
    gotoxy(1,2);
    frow := 1;
    for xx := LNN -20 TO LNN-1 DO
    begin
      makenewline(xx);
      astring :='                                                                               ';
      astring := sline[xx]^ + astring;
      if not nomem then directwrite(0,frow,att,astring);
      frow := frow +1;
    end;
end;

PROCEDURE FOutWPForm;
var xx : integer;
begin
  makenewline(lnn-1);
  gotoxy(1,1);
  if LNN > 20 then write(sline[lnn-1]^);clreol;
  gotoxy(1,2);
  frow := 1;
  for xx := LNN TO LNN + 19 DO
  begin
    makenewline(xx);
    astring :='                                                                               ';
    astring := sline[xx]^ + astring;
    if not nomem then directwrite(0,frow,att,astring);
    frow := frow +1;
  end;
end;

PROCEDURE SaveWP(filevar : str80);
var Py,xx,endln : integer;
    tempfilename : text;
begin
  If MAXLN > 1 then
  begin
    form;
    if markblock then
    begin
      gotoxy(1,24);
      write('Save Marked Block from line ',markone,' to ',marktwo ,' to disk Y/N ');clreol;
      repeat
         read(kbd,YN); YN := upcase(YN);
      until YN in ['Y','N'];
      if yn = 'N' then exit else yn := 'N';
    end
    else
    begin
      PromptAt(1,24,'Save Document as:' + FileVar +' Y/N ');
      repeat
        read(kbd,YN); YN := upcase(YN);
      until YN in ['Y','N'];
    end;
    if YN = 'N' then
    begin
      filevar :='';
      PromptAt(1,24,'Enter Document Name: ');
      readln(FileVar);
      if FileVar = '' then
      begin
        write('NOT Saved!'); delay(900); exit;
      end;
      filevar := upcasestr(filevar);
      if pos('.',filevar) = 0 then filevar := filevar + '.TXT';
    end;
    if markblock then
    begin
       xx := markone-1;
       endln := marktwo;
    end
    else
    begin
      xx := 0;
      endln := maxln;
    end;
    PromptAt(1,24,'Saving Document: '+ FileVar);
    assign(wpFileName,FileVar);
    if exist(filevar) then
    begin
      tempfile := filevar;
      py := pos('.',tempfile);
      if py <> 0 then delete(tempfile,py,4);
      tempfile := tempfile + '.bak';
      if exist(tempfile) then
      begin
        assign(tempfilename,tempfile);
        erase(tempfilename);
      end;
      if tempfile <> filevar then
      begin
        rename(wpfilename,tempfile);
        if ioerr then beep;
      end;
    end;
    assign(WPFileName,FileVar);
    if markblock then
    begin
      markblock := false;
      gotoxy(1,22); clreol;
    end
    else wpfilevar :=filevar;
    rewrite(WPFileName);
    if ioerr then
    begin
      close(wpfilename); if ioerr then exit;
    end;
    repeat
      xx := xx + 1;
      writeln(WPFileName,sline[xx]^);
      if ioerr then
      begin
        close(wpfilename); if ioerr then exit; exit;
      end;
    until (xx >= endln);
    if pos(^Z,sline[xx]^) = 0 then writeln(wpfilename,^Z);
    close(WPFileName);
    if ioerr then exit;
  end;
end;

PROCEDURE WPInputStr(var S: str80;L,X,Y : Integer;Term :CharSet;var TC : Char);
var
  spn,P,NLN,count,Tcount : Integer;
  LTR,LTRA,Ch,Fch : Char;

PROCEDURE movelinesdown(curLn : integer; NumLn : integer);
var termline : string[79];
begin
   for nln := maxln to maxln + numln do makenewline(nln);
   for nln := maxln+Numln downto curln+numln do sline[nln]^ := sline[nln-numln]^;
   maxln := maxln + numln;
   if numln > 1 then
   for nln := curln+1 to curln + numln do sline[nln]^ := '';
end;

PROCEDURE movelinesup(curLn : integer; NumLn : integer);
var termline : string[79];
begin
   for nln := maxln to maxln + numln do makenewline(nln);
   for nln := curln-1 to maxln do sline[nln]^ := sline[nln+numln]^;
   for nln := maxln to maxln + numln do sline[nln]^ := '';
   maxln := maxln - numln;
   if lnn > maxln then begin lnn := maxln; if not (ch in[^Y,^H]) then ch := ^R; end;
end;

PROCEDURE return;
begin
  NewLine := Copy(S,P + 1,L);
  Delete(S,P+1,L);
  gotoxy(1,Y+1);
  Write(S);clreol;
  gotoxy(1,22); DelLine;
  gotoxy(1,Y+2);
  if y <= 20 then
  begin
     gotoxy(1,Y+2); insline;
     write(newline);
     P:= wherey;
     clreol;
     gotoxy(1,22);clreol;
     gotoxy(1,P);
  end;
  x := 0;
  p := 0;
  movelinesdown(lnn,1);
  sline[lnn+1]^ :=newline;
end;

PROCEDURE MakeString;
begin
  if P < L then
  begin
    if ch = ^Q then
    begin
      write(chr(7));
      gotoxy(1,22); write('Insert Control Character');
      GotoXY(X + 1 + P,Y + 1);
      ch:= #00; read(kbd,ch);
      gotoxy(1,22); clreol;
      GotoXY(X + 1 + P,Y + 1);
    end;
    if InsertOn then
    begin
      if Length(S) >= L-1 then
      begin
        if p >= L-1 then begin beep; exit; end;
        p := p+1;
        pp:=p;
        Insert(Ch,S,P);
        return;
        p := pp;
        exit;
      end;
      P := P + 1;
      Insert(Ch,S,P);
      Write(Copy(S,P,L));clreol;
    end
    else
    begin
      if (P = Length(S)+1) or (P=0) and (Length(S)=1)
      then S := S + Ch
      else
      delete(S,P + 1,1);
      P := P + 1;
      Insert(Ch,S,P);
     Write(copy(S,P,L));clreol;
    end;
    if MaxLn < LNN then MaxLn :=LNN;
  end
  else Beep;
end;

PROCEDURE backspace;
begin
  fch := ch;
  Last := online + 1;
  if (LNN = maxln) and (p=0) and (length(s)=0) then
  begin                 {if at the end then just move up}
    Ch :=^E;
    Maxln := maxln - 1;
  end
  else        {else change to ^Y and delete current the line}
  if (P = 0) and (Length(s) = 0) then Ch := ^Y

  else            { else copy current line upto next line}
  if (Length(s) + Length(sline[LNN-1]^) <= 79) and (P = 0) and (LNN >1) then
  begin
    if S <> '' then Temp := Copy(S,P+1,L);
    s := '';
    ckln := sline[lnn-1]^;
    if (ckln <> '') and (ckln[length(ckln)] <> ' ') then
    sline[lnn-1]^ := sline[lnn-1]^ + ' ' + Temp {move with space}

    else
    sline[lnn-1]^ := sline[lnn-1]^ + Temp;   {move without space}
    gotoxy(1,y);
    write(sline[lnn-1]^); clreol; {write new line}
    gotoxy(1,Y+1); delline;
    gotoxy(1,21); insline;
    LineNum := 21 - Last + lnn;
    if linenum > 0 then
    begin
        makenewline(linenum+1);
        write(sline[LineNum+1]^);clreol;
    end;
    P := length(ckln);
    gotoxy(p+1,y);
    temp := sline[lnn-1]^;
    if lnn < maxln then movelinesup(lnn,1);
    sline[lnn-1]^ := temp;
    ch := ^E;
  end;
end;

PROCEDURE TabLeft;
begin
  if P > 0 then
  begin
    count := P;
    repeat
      count := count - 1;
      LTR := S[count];
      LTRA := S[count-1];
      P := P - 1;
    until ((LTR = ' ') and (LTRA in [#33..#126])) or (P = 0);
    if P > 0 then P := P-1
  end
  else beep;
end;

PROCEDURE TabRight;
begin
  if P < Length(S) then
  begin
    count := P;
    repeat
      count := count + 1;
      LTR:= S[count];
      LTRA := S[count+1];
      P := P + 1;
    until ((LTR = ' ') and (LTRA in [#33..#126]))or (P = Length(S));
  end
  else
  begin
    count := P;
    if lnn > 1 then ckln := sline[lnn-1]^ else ckln := '';
    if ckln <> '' then
    repeat
      count := count + 1;
      LTR:= ckln[count];
      LTRA := ckln[count+1];
      s := s + ' ';
      p:=p+1;
    until ((LTR = ' ') and (LTRA in [#33..#126])) or (P = length(ckln));
  end;
end;

PROCEDURE upcaseltr;
begin
  s[p+1] := upcase(s[p+1]);
  Write(Copy(S,P + 1,L));clreol;
  ch:=^D;
end;

PROCEDURE lowcaseltr;
begin
  s[p+1] := lowcase(s[p+1]);
  Write(Copy(S,P + 1,L));clreol;
  ch:=^D;
end;

PROCEDURE DeleteLeftChar;
begin
  Delete(S,P,1);
  Write(^H,copy(S,P,L));clreol;
  P := P - 1;
end;

PROCEDURE DeleteChar;
begin
  if P < Length(S) then
  begin
    Delete(S,P + 1,1);
    Write(Copy(S,P + 1,L));clreol;
  end;
end;

PROCEDURE MarkTop;
begin
  inserton := true;
  MarkOne := LNN;
  GOTOXY(1,22);clreol; lowvideo;
  WRITE('Top of Block Marked at Line: ',MarkOne);
  normvideo;
end;

PROCEDURE MarkBottom;
begin
  MarkTwo := LNN;
  xx := 0;
  repeat
    dline[xx+1] := sline[markone + xx]^;
    xx := xx +1;
  until (xx >= (marktwo + 1 - markone)) or (xx = 99);
  GOTOXY(1,22);clreol;
  lowvideo;
  WRITE('Top of Block Marked at Line: ',MarkOne,' - Bottom Mark at Line: ',MarkTwo);
  normvideo;
  if MarkOne < MarkTwo then MarkBlock := true else markblock := false;
  if markone >= marktwo then
  begin
    markone := 0;
    marktwo := 0;
    markblock := false;
    GOTOXY(1,22);clreol;
  end;
end;

 PROCEDURE KopyBlock;
 begin
   if (MarkBlock) and (sline[lnn]^ = '') then
   begin
     if marktwo - markone > 99 then marktwo := markone + 98;
     gotoxy(1,22); clreol;
     PriorLN := LNN;
     movelinesdown(lnn,(marktwo-markone)+1);
     for nln:= lnn to lnn +(marktwo-markone) do sline[NLN]^ := dline[nln-lnn+1];
     MarkBlock := false;
   end else
   if (lnn >= markone) and (lnn <= marktwo) then
   begin
     bigw;
     beep;
     PromptAt(1,24,'Delete Lines '); write(markone,' to ',marktwo,' ? Y/N');
     repeat read(kbd,yn);yn :=upcase(yn); until yn in ['Y','N'];
     if yn = 'Y' then  movelinesup(markone+1,marktwo-markone+1);
     markblock := false;
     markone:= 0;
     marktwo :=0;
     gotoxy(1,22); clreol;
   end;
   wpstatus;
end;

PROCEDURE Load66;
begin
  if sline[lnn]^ = '' then
  begin
    bigw;
    Inserton := true;
    if lnn mod 20 = 0 then priorln := lnn +1 else priorln := lnn;
    repeat
       PromptAt(1,24,'Read Disk Directory ? Y/N ');
       repeat read(kbd,yn); yn := upcase(yn); until yn in['Y','N'];
       if yn = 'Y' then ListDir;
       PromptAt(1,24,'Enter Name of Disk Text File to Merge: ');
       read(DFilevar);
       if DFilevar <> '' then
       begin
         if pos('.',dfilevar) = 0 then dfilevar := dfilevar + '.TXT';
         assign(DFileName,DFilevar);
         reset(DFileName);
         if ioerr then begin wpstatus; exit; end;
       end;
     until not ioerr;
     if DFilevar <> '' then
     begin
       while not eof(DFileName) do
       begin
         xx := xx + 1;
         if xx <= 99 then Readln(DFileName,dline[xx])
         else readln(DFileName,junk);
         if ioerr then
         begin
           close(Dfilename); if ioerr then exit;
           wpstatus;
           exit;
         end;
      end;
      close(DFileName);
      if ioerr then
      begin
        close(Dfilename); if ioerr then exit;
        wpstatus;
        exit;
      end;
      if xx > 99 then xx := 99;
      NewLine := Copy(S,P + 1,L);
      Delete(S,P+1,L); gotoxy(1,Y+1);
      if Y<20 then write(S);clreol;
      count := 1;
      makenewline(maxln+1);
      movelinesdown(lnn,xx);
      for nln:= lnn to lnn +xx do sline[NLN]^ := dline[nln-lnn+1];
    end;
    wpstatus;
  end else begin beep; ch := #00; end;
end;

PROCEDURE YankItOut;
begin
  Last := online+1;
  if S <> '' then Temp := Copy(S,P+1,L);
  Write('');clreol;
  Delete(S,P + 1,L);
  if (P = 0) and (Length(S) = 0) then
  begin
    gotoxy(1,Y+1); delline;
    gotoxy(1,21); insline;
    if last > 1 then LineNum := lnn +(21 - Last) else linenum := lnn;
    makenewline(linenum);
    makenewline(linenum+1);
    write(sline[LineNum+1]^); clreol;
    gotoxy(1,last);
    gotoxy(1,22); clreol;
    gotoxy(1,Y+1);
    if lnn >= maxln then makenewline(lnn+1);
    if lnn < maxln then movelinesup(lnn+1,1);
    if maxln < LNN then Maxln := LNN;
    if fch in [^H,#127] then
    begin
      P := length(sline[lnn-1]^);
      ch := ^E;
      fch:=#00
    end else P := 0;
  end;
end;

PROCEDURE centerstr;
begin
  center(s);
  P:= 0;
  gotoxy(1,wherey);
  if Lnn < maxln then ch := ^X;
end;

PROCEDURE searchfile;
begin
  bigw;
  if Fword = '' then
  begin
    PromptAt(1,24,'Enter word to search for: ');
    readln(Fword);
    if fword <> '' then begin gotoxy(27,24);write(fword,' searching...'); end;
  end
  else
  begin
    PromptAt(1,24,'Continue Search for: '+Fword+ ' ? Y/N ');
    repeat
      read(kbd,Fch);
      Fch := upcase(fch);
    until Fch in ['Y','N'];
    if Fch = 'N' then
    begin
      PromptAt(1,24,'Enter word to search for: ');
      readln(Fword);
    end else write(Fch,' searching...');
  end;
  if Fword <> '' then
  begin
    Fword := upcasestr(Fword);

    Lns := Lnn-1;
    if Lnn < Maxln then
    repeat
       Lns := Lns +1;
       if length(sline[lns]^) >0 then ckln := copy(sline[lns]^,p+1,79)
       else ckln := sline[lns]^;
       ckln := upcasestr(ckln);
       pp := p;
       if pos(Fword,ckln) <> 0 then
       begin
         if LNS = lnn then
         begin
           P := pos(fword,ckln) +length(fword)-1 +pp;
           ch := #00;
         end
         else
         begin
           if lns < 20 then Lnn := lns else Lnn := lns -20;
           p := 0;
         end;
       end
       else
       p :=0;
     until (Lns >= maxln) or (pos(Fword,ckln) <> 0);
     if lns >= maxln then
     begin
       bigw;
       gotoxy(1,24); clreol;
       write(chr(7),'"',Fword,'" not found! Press any key to continue');
       read(kbd,zip);
       Fword := '';
       if (Maxln > 20) and (ch <> #00) then
       begin
         LNN := MaxLN-20;
         Ch := ^C;
       end
       else ch := #00;
     end;
   end
   else ch := #00;
   wpstatus;
   GotoXY(X + P + 1,Y + 1);
 end;

PROCEDURE moveleft;
begin
  if P > 0 then P := P - 1 else Beep;
end;

PROCEDURE moveright;
begin
  if P < Length(S) then P := P + 1 else beep;
end;

PROCEDURE wraponoff;
begin
   WrapOn := not WrapOn;
   writeWrapOn;
 end;

PROCEDURE InsertOnOff;
begin
  bigw;
  gotoxy(36,24); clreol;
  InsertOn := not InsertOn;
  lowvideo;
  if InsertOn then write('Insert-On: File-> ',WPFileVar)
  else write('OverWrite: File-> ',WPFileVar);
  highvideo;
end;

PROCEDURE PutItBack;
begin
  if Length(S + Temp) <= 79 then
  insert(Temp,S,P+1) else
  begin
    beep;
    repeat
      gotoxy(1,22);
      write('No room for insertion. Press <ESC> Key and insert blank line');
      delay(400);
      if keypressed then Read(KBD,Ch);
      gotoxy(1,22);clreol;
      delay(150);
    until Ch = #27;
  end;
  gotoXY(X + 1,Y + 1);
  Write(S);clreol;
end;


begin {wpinstring}
  GotoXY(X + 1,Y + 1); {Write(S);clreol;}
  fcol := x; frow := Y;
  astring :='                                                                               ';
  astring := s + astring;
  directwrite(fcol,frow,att,astring);
  if priorch = ^^ then P := PP else
  if length(sline[lnn]^) < PP then P := length(sline[lnn]^) else P := PP;
  tcount := 0;
  count := 0;
  xx := 0;
  REPEAT
    if markblock then
    begin
      GOTOXY(1,22);clreol;
      lowvideo;
      WRITE('Top of Block Marked at Line: ',MarkOne,' - Bottom Mark at Line: ',MarkTwo);
      highvideo;
    end;
    littlew;
    PP := P;
    GotoXY(X + P + 1,Y + 1);
    WPIBMCH(Ch);
    if ch in[^C,^J,^X,^<,^U,^\,' ',^D,^H,#127,^S] then
    begin
      if (ch =^C ) and ((maxln <= 20) or (maxln-(21-online)<lnn) and (online<>0)) then ch := #00;
      if (ch in[^C,^J,^X]) and (lnn >= maxln) then ch :=#00;
      if (ch = ^J) and ((lnn <= 20) and (maxln  <=20)) then
      begin
        online := maxln-1;
        Lnn := maxln-1;
        ch  := ^X;
      end;
      Case Ch of
        ^<  : upcaseltr;
        ^\  : lowcaseltr;
        ^J  : begin LNN := MaxLN-20; Ch := ^C ; end;
        ^U  : begin LNN := 1; FOutWPForm; online := 1; end;
        ' ' : begin
                if (Length(S) >= linewidth-5) and (P >= linewidth) and WrapOn
                then
                begin
                  if S[p] <> ' ' then
                  S := S + Ch;
                  Ch := ^M;
                end;
              end;
        ^D  : if LNN <= maxln then
              begin
                if (P = Length(S)) and (LNN <maxln) then
                begin
                  P := 0;
                  Ch := ^X;
                end;
              end else ch := #00;
    ^H,#127 :  backspace;

        ^S  : begin
                if (P = 0) then if LNN > 1 then
                begin
                   P := length(sline[lnn-1]^);
                   Ch := ^E;
                end else Ch := #00;
              end;

       end;
    end;

    case Ch of
 #32..#125,^Q : MakeString;
      #205    :  Centerstr;
      ^^      :  Searchfile;
      ^N      :  begin bigw; savewp(wpfilevar); wpstatus; end;
      ^O      :  TabLeft;
      ^I      :  TabRight;
      ^S      :  Moveleft;
      ^D      :  Moveright;
      ^A      :  P := 0;
      ^F      :  P := Length(S);
      ^G      :  DeleteChar;
      ^H,#127 :  if P > 0 then  DeleteleftChar else beep;
      ^T      :  MarkTop;
      ^B      :  MarkBottom;
      ^K      :  KopyBlock;
      ^L      :  Load66;
      ^Y      :  YankItOut;
      ^M      :  Return;
      ^P      :  PutItBack;
      ^V      :  InsertOnOff;
      ^W      :  wraponoff;
      #132    :  begin formright := true; formpara(lnn); ch := ^K; end;
      #133    :  begin formright := false; formpara(lnn); ch := ^K; end;
      #206    :  help;
     else if not (Ch in Term) then beep;
    end;
    PP := P;
    if not (ch in term) then textinfo;
    priorch := Ch;
    priorP := P;
    if (ch = ^E) and (lnn = 1) then begin beep; ch:=#00 end;
  until Ch in Term;
  TC := Ch;
end;


PROCEDURE WRITEHIGH(PromptStr : Str80);
var xx : integer;
begin
   for xx := 1 to length(PromptStr) do
   begin
     if ((PromptStr[xx] in ['A'..'Z']) and  (PromptStr[xx+1] = '(')
         or (pos(':',PromptStr) >= xx)) then highvideo else lowvideo;
     write(PromptStr[xx]);
  end;
end;


PROCEDURE PROMPT(PromptStr : Str80; TC_Set : CharSet; var CH : Char);
var pc : char;
begin
  gotoxy(1,24);
  writehigh(PromptStr);clreol;
  repeat
    read(kbd,pc);
    CH := upcase(pc);
    if not(CH in TC_Set) then Beep;
  until CH in TC_Set;
  write(CH);
  highvideo;
end;

PROCEDURE ClearTextWindow;
begin
  littlew;
  GotoXY(1,1);
  clrscr;
  bigw;
end;

PROCEDURE printer;
var keych : char;  n : integer;
begin
  if printerok then
  begin
  ClearTextWindow;
  gotoxy(1,1);
  writeln('You may send Control or Escape Character sequences to your printer for ');
  writeln('the purpose of setting your print style. (i.e. correspondence quality) ');
  writeln('Press ALL the necessary keys, then press return.  See your printer''s');
  writeln('instruction manual for more information.');
  repeat
    read(kbd,keych);
    write(keych);
    case keych of
      #27    : write(lst,#27);
      ^A..^Z : write(lst,keych);
      else write(lst,keych);
    end;
  until keych = ^M;
  WRITELN(LST);
  for n := 1 to 2 do
  writeln(lst,'abcdefghijklmnopqrstuvwxyz..1234567890/+-!?:ABCDEFGHIJKLMNOPQRSTUVWXYZ');
  WRITE(LST,CHR(12));
  ClearTextWindow
  end;
end;

PROCEDURE setprint;
var Pnumstr,PageStr,PauseStr : string[3];
    item : char;
begin
  noprint := false;
  ClearTextWindow;
  repeat
    PromptAt(1,24,' ');
    gotoxy(1,1);
    if pause = 'N' then  PauseStr := 'No' Else PauseStr := 'Yes';
    if pageYN = 'N' then  PageStr := 'No' Else PageStr := 'Yes';
    if numYN = 'N' then  PnumStr := 'No' Else PnumStr := 'Yes';
    writeln('            Print Format Parameters');
    writeln;
    writeln('1 - Top Margin is.............: ',Header:3,' lines');clreol;
    writeln;
    writeln('2 - Bottom Margin is..........: ',Bottom:3,' lines');clreol;
    writeln;
    writeln('3 - Left Margin is............: ',Margin:3,' spaces');clreol;
    writeln;
    linewidth := 80 - margin - margin-1;
    writeln('4 - Maximum Lines per Page is.: ',Pagesize:3,' lines');clreol;
    writeln;
    writeln('5 - Pause Between Pages.......: ',PauseStr:3);clreol;
    writeln;
    writeln('6 - Automatic Pagination......: ',PageStr:3);clreol;
    writeln;
    writeln('7 - Number All Pages..........: ',PnumStr:3);clreol;
    writeln;
    writeln('8 - Send setup characters to printer');
    writeln;
    writeln('9 - Return to Select Choice Menu');
    writeln;
    write('Select Item # to change or press ''C'' to Continue ');
    repeat
      read(kbd,item);
      item := upcase(item);
    until item in ['1'..'9','C'];
    if item <> 'C' then
    begin
      case item of
      '1':begin
            repeat gotoxy(34,3);clreol; readln(header);
            until header in [1..66];
          end;
      '2':begin
            repeat gotoxy(34,5);clreol; readln(bottom);
            until bottom in [0..15];
          end;
      '3':begin
            repeat gotoxy(34,7);clreol; readln(margin);
            until margin in [0..15];
          end;
      '4':begin
            repeat gotoxy(34,9);clreol; readln(pagesize);
            until pagesize in [40..90];
          end;
      '5':begin
            repeat gotoxy(33,11);clreol; read(kbd,pause);
            pause := upcase(pause);
            until pause in ['Y','N'];
          end;
      '6':begin
            repeat gotoxy(33,13);clreol; read(kbd,PageYN);
            pageYN := upcase(pageYN);
            until pageYN in ['Y','N'];
          end;
      '7':begin
            repeat gotoxy(33,15); clreol; read(kbd,NumYN);
            NumYn := Upcase(NumYn);
            until NumYN in ['Y','N'];
          end;
      '8': printer;
      '9': begin NoPrint := true; item :='C' end;
       end;

    end;
  until item = 'C';
end;

PROCEDURE InputWP;
const
  Term : CharSet  =  [^X,^M,^E,^K,^L,^R,^C,^Z,^^,^U];
var
  TC : Char;
  top : boolean;
begin
  top := true;
  SAVED := FALSE;
  LNN := 1;
  TC := #00;
  online := 1;
  FOutWPForm;

  repeat

    if ((TC in [^X,^M]) and (online >= 21)) then
                        begin
                           online := 20;
                           littlew;
                           gotoxy(1,1);delline;
                           gotoxy(1,21); insline;
                         end
  else
  if (TC = ^E) and (online = 0) then
                          begin
                              littlew;
                              gotoxy(1,21);clreol;
                              gotoxy(1,1);insline;
                              if lnn > 1 then write(sline[lnn-1]^);
                              online := 1;
                              if (online = 1) and (lnn = 1) then top := true
                              else top :=false;
                          end;

 makenewline(lnn);
 textinfo;
 WPInputStr(sline[LNN]^,79,0,online,Term,TC);
    if LNN <= 0 then LNN := 1;
    if TC in[^X,^M] then
    begin
      LNN := LNN + 1;
      online := online + 1;
    end

    else

    if (TC = ^E) and (not top or (lnn>1) )then
    begin
      if LNN > 1 then LNN := LNN - 1;
      if online <=0 then online := 1;
      if online > 20 then online := 20;
      if (online in[1..20]) then online := online - 1;
    end;

  if (TC =^C) and (LNN < aTOPEND +1) then
  begin
    TopLine := (trunc(Lnn/20) *20) + 21;
    Lnn := topline;
    online := (lnn mod 20);
    FOutWPForm;
  end;

  if (TC in[^K,^L]) and (LNN < aTOPEND +1) then
  begin
    online := 1;
    FOutWPForm;
  end;

  if (TC = ^R) then if (LNN <= 20) then
    begin
      LNN := 1; FOutWPForm; online := 1;
    end
    else
    if (LNN > 20) then
    begin
        BOutWPForm;
        lnn := lnn -20;
        online :=1;
     end;
 if TC = ^^ then
   begin
     LNN := Lns;
     if LNN > maxln then Lnn := maxln;
     foutwpform;
     online := 1;
     if (TC = ^^) and (pos(fword,ckln) <> 0) then
        PP := (pos(fword,ckln)-1+ length(fword));
   end;

  If MAXLN >= aENDLINE THEN MAXLN := aENDLINE-2;

  if (TC = ^M) or (TC = ^X) then if LNN = aENDLINE-1 then beep;

  if LNN <= 0 then LNN := 1
  else
  if LNN >= aENDLINE-1 then LNN := aENDLINE-2;
until TC = ^Z;
ClearTextWindow
end;

PROCEDURE EnterWP;
begin
    InsertOn := true;
    wpstatus;
    writewrapon;
    InputWP;
    gotoxy(1,25);clreol;
end;

PROCEDURE GETWPFILE;
var
  xx : integer;
  NewFileVar : string[60];
begin
  WPFileVar := 'NONAME.TXT';
  xx := 0;
  markblock :=false;
  MAXLN := 0;
  for xx := 1 to aendline do if sline[xx] <> nil then sline[xx]^ := '';
  for xx := 1 to 99 do  dline[xx] := '';
  cursor(on);
  repeat
    astring := cnotice;
    directwrite(0,0,7,astring);
    PROMPT('Select Choice:  C(reate or R(evise document,  D(irectory,  Q(uit,  U(tilitys ', ['D','C','R','Q','U'], Ch);
    if ch = 'U' then
    begin
      sysutil;
      form;
    end;
    if Ch = 'D' then
    begin
      ClearTextWindow;
      ListDir;
      window(1,1,80,25);
      form;
    end;
  if Ch = 'C' then
  begin
    PromptAt(1,24,'Enter Name of Document To Create: ');
    readln(WPFileVar);
    if WPFileVar = '' then WPFileVar := 'NONAME.TXT';
    IF pos('.',wpfilevar) = 0 then wpfilevar := wpfilevar + '.TXT';
    wpfilevar := UPCASESTR(WPFILEVAR);
    gotoxy(1,24); clreol;
  end;

  if Ch =  'R' then
  begin
    PromptAt(1,24,'Enter Name of Document To Load: ');
    readln(WPFileVar);
    if wpfilevar <> ''then
    begin
      IF pos('.',wpfilevar) = 0 then wpfilevar := wpfilevar + '.TXT';
      wpfilevar := UPCASESTR(WPFILEVAR);
      if WPFileVar = '' then ch := #00;
      gotoxy(1,24); clreol; write('Loading: ',WPFileVar);
      assign(WPFileName,WPFileVar);
      Reset(WPFileName);
      if ioresult <> 0 then
      begin
        PROMPT('File not found - Create New File ?  Y/N  ',['Y','N'],Ch);
        if Ch = 'Y' then ch := 'C';
        if Ch = 'N'then ch := #00;
      end
      else
      begin
        xx := 0;
        while not eof(WPFileName) do
        begin
          xx := xx + 1;
          makenewline(xx);
          if xx <= aendline-2 then Readln(WPFileName,sline[xx]^)
          else readln(wpfilename,junk);
          if ioerr then
          begin
             Close(wpfilename); exit;
          end;
          MAXLN := xx;
          if MAXLN > aendline then MAXLN := aendline-2;
        end;
        makenewline(xx+1);
        close(WPfileName);
        if ioerr then exit;
      end;
    end
    else ch := #00;
  end;
  until ch in ['C','R','Q'];
  if Ch <> 'Q' then Ch := 'W';
end;


PROCEDURE PrintIt(mm : boolean);
label quit;
VAR P1,P2,cnum,pagenum,counter,nl,LCNT,LM,Posn,lx : INTEGER;
    RP : char;
    tline : string[79];
    spaces : string[25];
    Firstname : string[40];
    SurName : string[40];
    LASTNAME,PAUSED : BOOLEAN;
    bufln,cmdline : string[79];
begin
  if printerok then
  begin
    noprint := false;
    PAUSED := FALSE;
    LASTNAME := FALSE;
    xx := 0;
    pageNum := 1;
    firstName := '';
    SURname := '';
    tline:= '';
    for xx := 1 to 99 do dline[xx] := '';
    xx:=0;
    COUNTER := 0;
    If maxln < 1 then getWPfile;
    spaces :=  ' ';
    PromptAt(1,24,'Review Print Format Parameters ? Y/N ');
    repeat
      read(kbd,RP);
      RP := Upcase(RP);
    until RP in ['Y','N'];
    if RP = 'Y' then SetPrint;
    if not noprint then
    begin
      ClearTextWindow;
      if margin > 1 then for LM := 1 to margin do
      begin
        spaces := spaces + ' ';
      end;
      if MM then
      begin
        repeat
          PromptAt(1,24,'Name of Disk Text File to Merge: ');clreol;
          read(DFilevar);
          ClearTextWindow;
          if DFilevar <> '' then
          begin
            IF pos('.',Dfilevar) = 0 then Dfilevar := Dfilevar + '.TXT';
            assign(DFileName,DFilevar);
            reset(DFileName);
            if ioerr then exit;
          end;
        until not ioerr;
      end else DFilevar := ' ';
      if DFilevar <> '' then
      begin
        gotoxy(1,24);clreol;
        write('Printing: ',WPFilevar);
        gotoxy(1,1);
        write('Press  <ESC>  to abort printing');
        repeat
          if keypressed then begin read(kbd,ch); if ch = #27 then goto quit; end;
          if (numYn = 'Y') and (pagenum <> 1) then writeln(lst,spaces,pagenum:39-margin);
          if ioerr then exit;
          pagenum := pageNum + 1;
          if header > 6 then FOR LCNT := 0 TO HEADER-6 DO
          begin
            WRITELN(LST);
            if ioerr then exit;
          end;

          if MM then
          begin
          repeat
            if keypressed then begin read(kbd,ch); if ch = #27 then goto quit; end;
            xx := xx + 1;
            if xx <= 99 then Readln(DFileName,dline[xx])
            else readln(DFileName,junk);
            if ioerr then exit;
            if xx = 1 then
            begin
              FirstName := copy(dline[xx],1,pos(' ',dline[xx])-1);
              lx := length(dline[xx]);
              tline := dline[xx];
              if lx > 0 then
              repeat
                ch := tline[lx];
                lx := lx - 1;
              until ch = ' ';
              surname :=  copy(dline[xx],lx+2,40);
            end;
            ckln := upcasestr(Dline[XX]);
            IF POS('@@',CKLN) <> 0 THEN LASTNAME := TRUE;
          until pos('@',dline[xx]) <> 0
          end
          else lastname := true;

          LNN := 1;
          counter := COUNTER + XX;
          REPEAT
            cnum := 0;
            if keypressed then begin read(kbd,ch); if ch = #27 then goto quit; end;
            counter := counter +1;
            ckln := upcasestr(sline[LNN]^);
            if MM then
            begin
              if Pos('{@}',ckln) <> 0 then
              begin
                LNN := Lnn + 1;
                for NL := 1 to XX-1 do writeln(lst,spaces,dline[NL]);
                if ioerr then exit;
              end
              else if Pos('{^',ckln) <> 0 then
              begin
                bufln := sline[lnn]^;
                if Pos('{^}',ckln) <> 0 then
                begin
                  Posn := pos('{',sline[LNN]^);
                  delete(sline[lnn]^,posn,3);
                  insert(firstname,sline[LNN]^,posn);
                end;
                ckln := upcasestr(sline[LNN]^);
                if Pos('{^^}',ckln) <> 0 then
                begin
                  Posn := pos('{',sline[LNN]^);
                  delete(sline[lnn]^,posn,4);
                  insert(surname,sline[LNN]^,posn);
                end;
                writeln(LST,spaces,sline[LNN]^);
                sline[lnn]^ := bufln;
                lnn := lnn + 1;
              end;
            end;
            ckln := upcasestr(sline[LNN]^);
            cmdline := sline[LNN]^;
            cmdline := cmdline + ' ';
            if (POS('{NP}',ckln) <> 0) or (pos('{UL}',ckln) <> 0) or (pos('{BP}',ckln) <> 0) then
            begin
              write(lst,spaces);
              if ioerr then exit;
              if pos('{UL}',ckln) <> 0 then
              begin
                P1 := pos('{',ckln);
                delete(cmdline,P1,4);
                P2 := pos('{',cmdline);
                if p2 = 0 then p2 := length(cmdline);
                delete(cmdline,P2,4);
                repeat
                  cnum := cnum + 1;
                  write(lst,cmdline[cnum]);
                  if ioerr then exit;
                until cnum= P2;
                repeat
                  cnum := cnum - 1;
                  write(lst,^H);
                  if ioerr then exit;
                until cnum = P1-1;
                repeat
                  cnum := cnum + 1;
                  write(lst,'_');
                if ioerr then exit;
                until cnum = P2-1;
                if cnum < length(cmdline) then
                repeat
                  cnum := cnum + 1;
                  write(lst,cmdline[cnum]);
                  if ioerr then exit;
                until cnum >= length(cmdline);
              end;
              if pos('{BP}',ckln) <> 0 then
              begin
                P1 := pos('{',ckln);
                delete(cmdline,P1,4);
                P2 := pos('{',cmdline);
                if p2 = 0 then p2 := length(cmdline);
                delete(cmdline,P2,4);
                repeat
                  cnum := cnum + 1;
                  write(lst,cmdline[cnum]);
                  if ioerr then exit;
                until cnum= P2;
                repeat
                  cnum := cnum - 1;
                  write(lst,^H);
                  if ioerr then exit;
                until cnum = P1-1;
                repeat
                  cnum := cnum + 1;
                  write(lst,cmdline[cnum]);
                  if ioerr then exit;
               until cnum = P2-1;
               if cnum < length(cmdline) then
               repeat
                 cnum := cnum + 1;
                 write(lst,cmdline[cnum]);
                 if ioerr then exit;
               until cnum >= length(cmdline);
             end;
             writeln(lst);
             if ioerr then exit;
           end
           else
           writeln(LST,spaces,sline[LNN]^);
           if ioerr then exit;
           ckln := upcasestr(sline[LNN]^);
           IF (((counter + HEADER + BOTTOM) MOD pagesize = 0) and (pageYN = 'Y'))
           or (POS('{NP}',ckln) <> 0) THEN
           BEGIN
             counter := 0;
             WRITE(LST,CHR(12));
             if ioerr then exit;
             if pause = 'Y' then
             begin
               PAUSED := TRUE;
               gotoxy(2,3);
               writeln('   Pausing between Pages...');
               write('Press Any Key to Continue Print');
               read(kbd,ch);
               if ch = #27 then goto quit;
               gotoxy(1,4);clreol;
             end;
             if numYn = 'Y' then writeln(lst,spaces,pagenum:39-margin);
             if ioerr then exit;
             pagenum := pageNum + 1;
             if header > 6 then FOR LCNT := 0 TO HEADER-6 DO WRITELN(LST);
             if ioerr then exit;
           END;
           LNN := LNN + 1;
         until EOF(WPFileName) or (LNN >= MAXLN + 1);
         xx := 0;
         write(lst,chr(12));
         if ioerr then exit;
         counter := 0;
         if (pause = 'Y') AND NOT PAUSED then
         begin
           PAUSED := FALSE;
           gotoxy(2,3);
           writeln('Pausing between Pages');
           write('Press Return to Continue or Esc to Quit');
           repeat
              read(kbd,ch);
           until ch in [#27,^M];
           if ch = #27 then goto quit;
           gotoxy(1,4);clreol;
         end;
         if keypressed then
         begin
            read(kbd,ch);
            if ch = #27 then goto quit;
         end;
       until lastname or EOF(DfileName);
       quit:
       if ch = #27 then WRITE(LST,CHR(12));
       if ioerr then exit;
       close(dfilename);
      end;
    end;
  end;
  clearTextWindow;
  form;
end;

PROCEDURE MailMergePrint;
begin
 printit(true);
end;

PROCEDURE RegularPrint;
begin
  printit(false);
end;

PROCEDURE initialize;
begin
  clrscr;
  Typeadapter;
  nomem := false;
  if crtmode = 3 then att := 14 else att := 15;
  form;
  noprint := false;
  getdir(0,Cdir);
  Fword := '';
  markone:=0;
  marktwo := 0;
  WrapOn := true;
  markblock := false;
  header := 7;
  pause := 'N';
  pageYN := 'Y';
  numYn := 'N';
  bottom := 7;
  pagesize := 66;
  margin := 9;
  linewidth := 80 - margin - margin;
  Temp := '';
  MAXLN := 0;
  mark(heaptop);
  for xx := 1 to endline do sline[xx] := nil;
  aendline := xx;
  atopend := xx-20;
end;

begin
  Initialize;
  GetWPFile;
  if Ch <> 'Q' then
  begin
    repeat
      priorch := #00;
      priorP := 0;
      PP := 0;
      markblock:=false;
      PROMPT('Select: E(nter text, G(et file, H(elp, M(erge, P(rint, S(ave, Q(uit, U(tility',
      ['M','G','S','P','H','E','Q','U'],ch);
      case Ch of
        'U' : SysUtil;
        'E' : EnterWP;
        'G' : begin
                IF (NOT SAVED) and (Maxln >0) THEN
                begin
                  form;
                  PromptAt(1,24,'File Not Saved!  Save it ? Y/N ');
                  repeat
                    read(kbd,Ch);
                    Ch := upcase(ch);
                  until Ch in ['Y','N'];
                  if ch = 'Y' then SaveWP(wpfilevar);
                end;
                GetWPFile;
              end;
        'H' : Help;
        'M' : Mailmergeprint;
        'P' : Regularprint;
        'S' : begin SaveWP(wpfilevar); Saved := True; end;
      end;
      form;
    until UpCase(Ch) = 'Q';
    if (NOT SAVED) and (MaxLn > 0) then
    begin
      beep;
      PromptAt(1,24,'File Not Saved!  Save it ? Y/N ');
      repeat
        read(kbd,Ch);
        Ch := upcase(ch);
      until Ch in ['Y','N'];
      if ch = 'Y' then SaveWP(wpfilevar);
    end;
  end;
  release(heaptop);
  clrscr;

  {    Please do not remove the following information from this program                       }

  writeln('If you find this program useful then please become a registered user by');
  writeln('sending a support fee of $25.00, or what ever you may be able to afford,');
  writeln('to:');
  writeln('      K.S. Software');
  writeln('      P.O. Box 37093 ');
  writeln('      Omaha, NE 68137');
  writeln;
  writeln('In return for your support fee of $25.00 you will receive the latest ');
  writeln('program version including turbo pascal source code.');
  writeln;
  writeln('In addition you will also receive a copy of "SUMDOS" a memory resident');
  writeln('utility program that includes:');
  writeln;
  writeln('Calculator, Note Pad, Disk Utilities, Read File, Terminal Communications,');
  writeln('Phone List and Dialer, ASCII Table, Screen Saver, Calendar and a handy');
  writeln('utility to write screens to disk.');
  writeln;
  writeln;
  writeln('Permission is granted to make copies of this program and distribute copies');
  writeln('to others for non-profit purposes only.');
 end.